perm filename T1.F4[M11,LCS]2 blob
sn#396923 filedate 1978-11-22 generic text, type T, neo UTF8
00100 C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
00200 DIMENSION W(35),IINS(135),FQDR(28,27)
00300 C W(35) FOR PARAMETERS
00400 COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,5),MX5(40)
00500 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00600 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
00700 1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN
00800 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
00900 INTEGER FQDR
01000 CXX DOUBLE PRECISION IDBL,JANP,JBLA,IAT,IPERC,JFLNM,IDBG
01100 EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
01200 1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
01300 1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
01400 1,(IAROW,LX(7))
01500 CXX DATA LX/' ',';', '*','/','-','+'
01600 CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
01700 DATA LX/' ',';', '*','/','-','+'
01800 1,"575004020100,'=','<' ,',' ,'(', ')'/, IFIRST/-1/,IOPEN/-1/
01900 1 , IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/,IAT/'@ '/
02000 1,JBLA/' '/,IDBG/'# '/,JDBG/'#'/
02100 C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
02200 DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
02300 1,IEXP/'!'/,IPERC/'% '/,JANP/'& '/
02400 1,IANP/'&'/
02500 1,IALT/"765004020100/
02600 CXX 1,IALT/'"'/
02700 555 LLLL=0
02800 401 IF(IFIRST)404, 5,600
02900 404 IGEN=-1
03000 IF(INUM.NE.0)GO TO 30
03100 DO 411 K=1,135
03200 411 IINS(K)=0
03300 C ZERO OUT INSTR. NAME ARRAY.
03400 30 IPLAY=0
03500 ENDX=0
03600 JSEM=0
03700 INS=-1
03800 402 IDEV=1
03900 TYPE 1
04000 1 FORMAT(' INPUT? '$)
04100 100 FORMAT(' >'$)
04200 2 FORMAT(A4)
04300 ACCEPT 2,IDBL
04400 C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
04500 IF(IDBL.NE.JBLA)GO TO 400
04600 IDEV=5
04700 GO TO 5
04800 400 IF(IDBL.EQ.JANP)GO TO 603
04900 C!*** & IS PRNT-NOPRNT FLIPFLOP
05000 IF(IDBL.NE.IDBG)GO TO 410
05100 4448 TYPE 4023
05200 4446 TYPE 4445
05300 ACCEPT 51,KI
05400 IF(KI.EQ.0)GO TO 4022
05500 IF(KI.GT.0)GO TO 4447
05600 C******** THIS STUFF FOR DIAGNOSIS
05700 IF(KI.EQ.-1)TYPE 2325,IGEN
05800 IF(KI.EQ.-2)TYPE 2325,IPRNT
05900 IF(KI.EQ.-3)TYPE 2325,IPLAY
06000 IF(KI.EQ.-4)TYPE 2325,JSEM
06100 IF(KI.EQ.-5)TYPE 2325,J
06200 IF(KI.EQ.-6)TYPE 2325,MM
06300 GO TO 4446
06400 4022 IF(IDEV.EQ.1)GO TO 402
06500 C GO BACK TO 'INPUT' OR '>'
06600 GO TO 502
06700 C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
06800 4447 TYPE 2326,LX(KI)
06900 TYPE 2325,LX(KI)
07000 GO TO 4446
07100 4445 FORMAT(' TYPE LX NUMB. '$)
07200 4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
07300 4444 IF(IDBL.NE.IAT)GO TO 410
07400 C!*** @ IS USED TO SET OUTPUT FILE NAME (DEFAULT=FOR21)
07500 TYPE 399
07600 399 FORMAT(' TYPE OUTPUT NAME -- ',$)
07700 ACCEPT 2,JFLNM
07800 GO TO 402
07900 CCC IF(IDBL.EQ.'%')GO TO 604
08000 C!*** % IS WRT-NOWRT FLIPFLOP
08100 C! % WRITES BINARY FILE.
08200 2324 FORMAT(1X12F/)
08300 2325 FORMAT(1X5I/)
08400 2326 FORMAT(1X80A1)
08500 CX410 CALL OPEN(1,IDBL,0,'RDO')
08600 410 CALL IFILE(1,IDBL)
08700 4 FORMAT(80A1)
08800 C****************
08900 CX TYPE 2325,JSEM
09000 CX TYPE 2325,J
09100 CX TYPE 2325,MM
09200 5 IF(JSEM.AND.J.LT.MM)GO TO 305
09300 IF(JSEM.NE.99)GO TO 502
09400 IFIRST=IFIRST+10
09500 GO TO 555
09600 600 JSEM=0
09700 IFIRST=IFIRST-10
09800 INS=-1
09900 502 IF(IDEV.NE.5)GO TO 601
10000 CX TYPE 2325,IDEV
10100 C*******************************
10200 IF(IGEN.NE.2)IGEN=-1
10300 TYPE 100
10400 CX601 TYPE 2325,INS
10500 C*******************************
10600 601 READ(IDEV,4,END=404)I
10700 IF(IDEV.EQ.5)GO TO 1232
10800 KI=80
10900 1233 IF(I(KI).NE.IBLA)GO TO 1234
11000 KI=KI-1
11100 IF(KI.GT.0)GO TO 1233
11200 1234 TYPE 2326,(I(IJI),IJI=1,KI)
11300 GO TO 602
11400 1232 IF(I(1).EQ.IBLA)GO TO 404
11500 C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?'
11600 IF(I(1).EQ.JDBG)GO TO 4448
11700 C TYPE '#' FOR SOME DEBUGGING
11800 CCC IF(I(1).EQ.'%')GO TO 604
11900 C!*** %=WRITES BINARY FILE FOR21.DAT
12000 IF(I(1).NE.IANP)GO TO 602
12100 C!*** &=TYPE OUT MUS5 NUMBERS
12200 603 JPRNT=-JPRNT
12300 IF(IDEV.EQ.1)GO TO 402
12400 C IDEV=1 = GO BACK TO 'INPUT'
12500 GO TO 502
12600 CCC604 JWRT=-JWRT
12700 C!*** DEFAULT IS NO-WRITE BINARY
12800 CCC GO TO 401
12900 602 IF(I(1).NE.IALT)GO TO 408
13000 CCC IF(I(2).NE.'I')GO TO 605
13100 C!***<ALT>I(NSTRUMENT LIST;) ALT IS DBL QUOTE IN THIS PROG. FOR NOW.
13200 DO 606 K=1,INUM
13300 JK=NPAR(K)-2
13400 606 TYPE 607,(INST(K,L),L=1,5),INSNUM(K),JK
13500 GO TO 5
13600 607 FORMAT(1X,5A1,' NUM=',I2,' PARAMS=',I2)
13700 C!*** PRINTS INST INFO.
13800 CCC605 SBFILN=FILNM
13900 CCCCC CALL PLAY
14000 C!**** GO PLAY SOMETHING
14100 CCC GO TO 5
14200 408 DO 407 K=1,100
14300 407 JX(K)=IBLA
14400 DO 405 K=1,80
14500 IF(I(K).EQ.LESS)GO TO 5
14600 405 IF(I(K).NE.IBLA)GO TO 406
14700 GO TO 5
14800 406 MM=0
14900 DO 4061 J=2,100,2
15000 4061 RX(J)=0
15100 J=-1
15200 IPRNT=0
15300 JI=0
15400 9 M=0
15500 N=JI+1
15600 6 JI=JI+1
15700 K=I(JI)
15800 DO 7 L=1,12
15900 7 IF(K.EQ.LX(L))GO TO 8
16000 M=M+1
16100 GO TO 6
16200 C!**** NO STRING CAN EXCEED 10 CHARS.
16300 8 IF(K.EQ.LESS)GO TO 15
16400 IF(M.EQ.0)GO TO 140
16500 IF(M.GT.10)M=10
16600 MM=MM+1
16700 IF(MM.LE.50)GO TO 88
16800 TYPE 888,(I(JJ),JJ=N,N+9)
16900 STOP
17000 888 FORMAT(' LINE TOO LONG -- ',10A1)
17100 88 JJ=I(N)
17200 IF(JJ.GT.'9')GO TO 16
17300 IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
17400 CXX IF(JJ.GT.8249)GO TO 16
17500 CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
17600 C**** 8240='0' 8249='9'
17700 C!***** JUMP IF 1ST CHAR. IS A LETTER.
17800 Y=0
17900 DOT=10.
18000 DO 18 JK=N,N+M-1
18100 JA=I(JK)
18200 IF(JA.NE.IDOT)GO TO 17
18300 DOT=.1
18400 GO TO 18
18500 CXX17 X=JA-8240
18600 17 X=NASCI(JA)
18700 C!**** CHANGE ASCII INTO NUMBER
18800 IF(DOT.LT.1)GO TO 19
18900 Y=Y*DOT+X
19000 GO TO 18
19100 19 Y=Y+X*DOT
19200 DOT=DOT/10.
19300 18 CONTINUE
19400 RX(MM*2-1)=Y
19500 RX(MM*2)=-9999.0
19600 GO TO 140
19700 CCC16161 FORMAT(1X,I,3X10A1)
19800
19900 16 JK=MM*2-1
20000 CX JX(JK)=0
20100 CX RX(JK)=0
20200 CX JX(JK+1)=0
20300 CX RX(JK+1)=0
20400 CALL MPACK(M,I(N),JX(JK),N)
20500 C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
20600 IJ=JX(JK)
20700 CCC IF(JPRNT)TYPE 16161,IJ,(I(KHH),KHH=N,N+M-1)
20800 IF(IJ.GE.0)GO TO 244
20900 JX(MM*2)=M
21000 C SAVE THE WD CNT OF POTENTIAL INST. NAME.
21100 GO TO 10
21200 244 IF(IJ.NE.412)GO TO 140
21300 C 412='INSTRUMENT'
21400 INS=0
21500 GO TO 5
21600 144 MX=MX+1
21700 MX5(MX)=IXJ
21800 C!*** PUT IS NEW UNIT GEN. NAME
21900 MX=MX+1
22000 MX5(MX)=RX(3)
22100 GO TO 5
22200 140 IF(IJ.NE.413)GO TO 143
22300 CCC140 IF(IXJ.NE.'UNIT')GO TO 143
22400 INS=1
22500 C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
22600 GO TO 5
22700 143 IF(K.EQ.IBLA)GO TO 10
22800 IF(L.EQ.8)K=IAROW
22900 C!::: CHANGE = INTO ←
23000 MM=MM+1
23100 KI=MM*2-1
23200 JX(KI)=K
23300 CC JX(MM*2-1)=K
23400 10 IF(I(JI+1).NE.IBLA)GO TO 11
23500 JI=JI+1
23600 GO TO 10
23700 11 IF(JI.LT.80)GO TO 9
23800 C NOW WE HAVE ALL ITEMS IN IX ARRAY
23900 15 MM=MM*2
24000 IF(IJ.NE.404)GO TO 142
24100 CCC IF(IXJ.NE.KPRNT)GO TO 142
24200 INS=-1
24300 C!***** FOR 'PRINT'
24400 IPRNT=-1
24500 142 J=-1
24600 IF(INS.LT.0)GO TO 305
24700 IF(INS.EQ.2)GO TO 305
24800 26 IF(IJ.NE.12)GO TO 127
24900 CCC26 IF(IXJ.NE.'END')GO TO 127
25000 MM=0
25100 INS=-1
25200 C!***** NOW INITITIALIZATION COMPLETE
25300 GO TO 5
25400 127 IF(INS.EQ.1)GO TO 144
25500 C!*** FOR 'UNIT GEN' ADDED
25600 CXCX ASSUMES INST NAME STARTS IN COL.1 L=N-1
25700 L=0
25800 M=JX(2)
25900 IF(INUM.EQ.0)GO TO 2127
26000 DO 1127 KL=1,INUM
26100 C!** FOR POSSIBLE REDEFINITION OF INST.
26200 CC1127 IF(IXJ.EQ.INST(KL))GO TO 3127
26300 DO 21 LQ=1,M
26400 21 IF(INST(KL,LQ).NE.I(L+LQ))GO TO 1127
26500 C TRY TO MATCH UP LETTERS WITH EXISTING INST. NAMES.
26600 GO TO 3127
26700 C!*** IS INST ALREADY IN LIST?
26800 C JUMP OUT IF MATCH WAS FOUND
26900 1127 CONTINUE
27000 2127 INUM=INUM+1
27100 K=INUM
27200 CC3127 INST(K)=IXJ
27300 DO 20 LQ=1,M
27400 20 INST(K,LQ)=I(L+LQ)
27500 C!**** GET THE NAME OF AN INST.(5 LTRS ONLY)
27600 3127 INSNUM(K)=RX2
27700 C!*** GET ITS NUMBER.
27800 NPAR(K)=RX3+2
27900 C!**** GET NUM OF PARAMS, ADD 3 FOR W ARRAY
28000 DO 2328 KI=1,NPAR(INUM)
28100 2328 FQDR(KI,INUM)=0
28200 K=7
28300 28 LL=-1
28400 IF(JX(K).NE.410)GO TO 31
28500 CCC IF(JX(K).NE.IDUR)GO TO 31
28600 C IF IT'S NOT 'DUR' THEN IT MUST BE 'FREQ'
28700 LL=-LL
28800 C!*** NOW LOOK AT REST OF THE LINE
28900 31 K=K+2
29000 IF(K.GT.MM)GO TO 5
29100 C!**** CHECK FOR END OF LINE
29200 IF(RX(K+1).NE.-9999.0)GO TO 28
29300 JA=RX(K)-2
29400 CC JA=RX(K)+2
29500 IF(JA.LT.1)GO TO 31
29600 CC IF(JA.LT.5)GO TO 31
29700 FQDR(JA,INUM)=LL
29800 C!***** IGNORE P1,P2 OF INPUT
29900 C!**** 1=DUR, -1=FREQ, 0=ORDINARY NUM.
30000 GO TO 31
30100 50 IF(IGEN)308,309,309
30200 309 LL=LL-1
30300 IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
30400 C!*** FOUND 'END'
30500 GO TO 59
30600 308 W(1)=1
30700 IF(LL-1.GE.NPAR(IK))GO TO 56
30800 54 IF(LL.LT.3)LL=3
30900 DO 55 K=LL,NPAR(IK)-1
31000 55 W(K)=P(K-2)
31100 C!***** GET INFO ALREADY IN PARAMS
31200 56 DO 57 K=3,LL-1
31300 57 P(K-2)=W(K)
31400 C!**** FILL UP P LIST AGAIN
31500 X=W(3)
31600 C!*** EXCHANGE W(2) AND W(3), ACTION TIME, INST #
31700 W(3)=W(2)
31800 W(2)=X
31900 58 LL=NPAR(IK)
32000 DO 52 K=5,LL-1
32100 KI=FQDR(K-4,IK)
32200 CC X=FQDR(K-4,IK)
32300 IF(KI)53,52,2352
32400 CC IF(X.EQ.0)GO TO 52
32500 CC IF(X)GO TO 53
32600 2352 W(K)=RMAG/W(K)
32700 GO TO 52
32800 53 W(K)=RMAG*W(K)
32900 52 CONTINUE
33000 IF(ENDX.LT.W(2)+P2)ENDX=W(2)+P2
33100 W(LL)=RMAG/W(4)
33200 C!********* PUT MAG/P2 AT END
33300 59 IF(JPRNT.GE.0)GO TO 591
33400 CC TYPE 590,KNAM
33500 KNAM=IBLA
33600 TYPE 51,LL,(W(K),K=1,LL)
33700 CXX WRITE(22,51)LL,(W(K),K=1,LL)
33800 C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
33900 591 IF(JWRT.GE.0)GO TO 500
34000 IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
34100 CXX IF(IOPEN.LT.0)CALL OPEN(21,JFLNM,0,'NEW',,,'UNF')
34200 C OPENS FILE, IF NOT ALREADY OPEN.
34300 WRITE(21)LL,(W(K),K=1,LL)
34400 IOPEN=0
34500 500 IFIRST=0
34600 IF(IGEN.EQ.0)IGEN=-1
34700 GO TO 555
34800 CC RETURN
34900 590 FORMAT(I6)
35000 CCC590 FORMAT(1XA5,1X$)
35100
35200 306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
35300 IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
35400 IPRNT=0
35500 C!** RESET NO-PRNT FLAG
35600 JSEM=0
35700 C!** RESET SEMICOLON FLAG
35800 INS=-1
35900 IF(J.GE.MM-1)GO TO 5
36000 C!** GO READ ANOTHER LINE
36100 305 CALL MSCAN(LL,W)
36200 303 IF(IPRNT.LT.0)GO TO 306
36300 IF(J.LT.MM)JSEM=-1
36400 C!**** STILL MORE CHARS TO COME.
36500 IF(ENDX.GE.0)GO TO 302
36600 ENDX=0
36700 GO TO 500
36800 302 IF(JSEM)50,5,5
36900 51 FORMAT(I3,35F10.3)
37000 307 FORMAT('+',F8.2,$)
37100 1307 FORMAT(F10.3)
37200 END
37300
37400 FUNCTION NASCI(N)
37500 DATA IEX/536870912/,IZERO/'0'/
37600 C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
37700 NASCI=(N-IZERO)/IEX
37800 C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
37900 END